home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / intrfc70.zip / RELOC.PAS < prev    next >
Pascal/Delphi Source File  |  1994-03-16  |  5KB  |  173 lines
  1. unit reloc;
  2. {$I SWITCHES.INC}
  3. { unit to print relocation records }
  4.  
  5. interface
  6. uses dump,util,globals,loader,nametype,head;
  7.  
  8. type
  9.   reloc_ptr = ^reloc_rec;
  10.   reloc_rec = record
  11.     unit_num,            { offset to unit in unit block }
  12.     rtype : byte;
  13.     rblock,roffset,offset : word;
  14.   end;
  15.  
  16. const
  17.   code_seg  = 0;
  18.   code_data = 1;
  19.   var_seg   = 2;
  20.   const_seg = 3;
  21.  
  22. procedure print_reloc(seg:byte);
  23. procedure write_reloc_type(rtype:byte);
  24.  
  25. implementation
  26.  
  27. uses
  28.   blocks,namelist;
  29.  
  30. function ref_type(rtype:byte):byte;
  31. begin
  32.   ref_type := (rtype shr 4) and 3;
  33. end;
  34.  
  35. function target_type(rtype:byte):byte;
  36. begin
  37.   target_type := rtype shr 6;
  38. end;
  39.  
  40. procedure print_reloc(seg:byte);
  41. var
  42.   codebase,codeofs,codelimit,
  43.   base,ofs,limit : word;
  44.   block : reloc_ptr;
  45.   code_block : block_ptr;
  46.   target_unit : unit_list_ptr;
  47.   entry_pt : entry_pt_ptr;
  48.   target_unit_name : string;
  49. begin
  50.   writeln;
  51.   case seg of
  52.   code_seg : begin
  53.         writeln('Code segment relocation records');
  54.         if header^.reloc_size = 0 then
  55.         begin
  56.           writeln('(none)');
  57.           exit;
  58.         end;
  59.         codebase :=header^.ofs_code_blocks;
  60.         codelimit := header^.ofs_const_blocks-codebase;
  61.      end;
  62.  
  63.   const_seg : begin
  64.         writeln('Const segment relocation records');
  65.         if header^.const_reloc_size = 0 then
  66.         begin
  67.           writeln('(none)');
  68.           exit;
  69.         end;
  70.         codebase :=header^.ofs_const_blocks;
  71.         codelimit := header^.ofs_var_blocks-codebase;
  72.      end;
  73.   end;
  74.   writeln('  Reloc');
  75.   writeln('  Offset  Fixup    Type      Unit    Block:Offset');
  76.   base := 0;
  77.   codeofs := 0;
  78.   while codeofs < codelimit do
  79.   begin
  80.     code_block := add_only_offset(buffer,codebase+codeofs);
  81.     write('---');
  82.     case seg of
  83.       code_seg:  write_code_block_name(unit_list[1],codeofs);
  84.       const_seg: write_const_block_name(code_block^.owner);
  85.     end;
  86.     writeln('---');
  87.     ofs := 0;
  88.     limit := code_block^.relocbytes;
  89.     while ofs < limit do
  90.     begin
  91.       block := add_only_offset(reloc_buf,base+ofs);
  92.       with block^ do
  93.       begin
  94.         write(hexwordblank(codeofs),':',hexword(offset),' ');
  95.         if (rtype = $FF) and (unit_num = $FF) then
  96.         begin
  97.           write('Coproc   ');
  98.           case rblock of
  99.           1 : write('DS override');
  100.           2 : write('SS override');
  101.           3 : write('CS override');
  102.           4 : write('ES override');
  103.           5 : write('Standard');
  104.           6 : write('FWAIT');
  105.           else
  106.             WriteError('Unrecognized fixup type '+hexword(rblock));
  107.           end;
  108.           if roffset <> 0 then
  109.             write(' ROffset = ',hexword(Roffset));
  110.         end
  111.         else
  112.         begin
  113.           write_reloc_type(rtype);
  114.           target_unit_name := unit_name(unit_num);
  115.           write(target_unit_name:10);
  116.  
  117.           if target_type(rtype) = 0 then  { This doesn't catch Coproc fixups }
  118.           begin
  119.             { It might be a good idea to try to add the unit to the unit_list
  120.               here, but I don't think so.  Let it fail if it wants to. }
  121.  
  122.             target_unit := get_unit_by_name(target_unit_name);
  123.  
  124.             if (target_unit <> nil) and (target_unit^.buffer <> nil) then
  125.               with target_unit^ do
  126.               begin
  127.                 entry_pt := add_only_offset(buffer,
  128.                              header_ptr(buffer)^.ofs_entry_pts+rblock);
  129.                 write(' ',hexwordblank(entry_pt^.code_block),':',
  130.                       hexword(entry_pt^.offset),'   ');
  131.                 write(find_proc_with_entry(target_unit,rblock));
  132.               end
  133.             else
  134.               write(' entry',hexword(rblock));
  135.           end
  136.           else
  137.             write(' ',hexwordblank(rblock),':',hexword(roffset));
  138.         end;
  139.         writeln;
  140.       end;
  141.       inc(ofs,sizeof(reloc_rec));
  142.     end;
  143.     inc(base,ofs);
  144.     inc(codeofs,sizeof(block_rec));
  145.   end;
  146. end;
  147.  
  148. procedure write_reloc_type(rtype:byte);
  149. begin
  150.   if (rtype and $0F) <> 0 then
  151.     WriteError  ('Unknown type   '+hexbyte(rtype));
  152.  
  153.   case ref_type(rtype) of
  154.   0 : write('Relative ');
  155.   1 : write('Offset   ');
  156.   2 : write('Segment  ');
  157.   3 : write('Pointer  ');
  158.   else
  159.     WriteError('Unknown ref_type');
  160.   end;
  161.  
  162.   case target_type(rtype) of
  163.   code_seg  : write('Code    ');
  164.   code_data : write('CS Const');
  165.   var_seg   : write('Var     ');
  166.   const_seg : write('DS Const');
  167.   else
  168.     WriteError('Unknown target_type');
  169.   end;
  170. end;
  171.  
  172. end.
  173.